home *** CD-ROM | disk | FTP | other *** search
/ Amiga Plus 1995 #5 & #6 / Amiga Plus CD - 1995 - No. 5 and 6.iso / pd / serien / purity / nr.46 / pcq-crt / crt.p < prev    next >
Text File  |  1995-04-18  |  3KB  |  176 lines
  1. External;
  2.  
  3. { Crt.p for PCQ-Pascal. Copyright © 1995 by Andreas Tetzl }
  4. { Version 1.0 (15.04.1995) }
  5.  
  6. {$I "Include:Intuition/Intuition.i"}
  7. {$I "Include:Intuition/IntuitionBase.i"}
  8. {$I "Include:Graphics/RastPort.i"}
  9. {$I "Include:Utils/StringLib.i"}
  10.  
  11. const    CSI = chr($9b);
  12.  
  13. PROCEDURE Locate(Zeile, Spalte : Byte);
  14. Begin
  15.  Write(CSI,Zeile,";",Spalte,"H");
  16. end;
  17.  
  18. PROCEDURE ClrScr;
  19. Begin
  20.  Write(Chr($0c));
  21. end;
  22.  
  23. PROCEDURE CursorOff;
  24. Begin
  25.  Write(CSI,"0 p");
  26. end;
  27.  
  28. PROCEDURE CursorOn;
  29. Begin
  30.  Write(CSI,"1 p");
  31. end;
  32.  
  33. PROCEDURE Bell;
  34. Begin
  35.  Write(Chr($07));
  36. end;
  37.  
  38. PROCEDURE MoveCursorUp(n : Byte);
  39. Begin
  40.  Write(CSI,n,"A");
  41. end;
  42.  
  43. PROCEDURE MoveCursorDown(n : Byte);
  44. Begin
  45.  Write(CSI,n,"B");
  46. end;
  47.  
  48. PROCEDURE MoveCursorLeft(n : Byte);
  49. Begin
  50.  Write(CSI,n,"D");
  51. end;
  52.  
  53. PROCEDURE MoveCursorRight(n : Byte);
  54. Begin
  55.  Write(CSI,n,"C");
  56. end;
  57.  
  58. PROCEDURE ResetConsole;
  59. Begin
  60.  Write("\ec");
  61. end;
  62.  
  63. PROCEDURE SetTextStyle(Style, fCol, bCol : Byte);
  64. Begin
  65.  Write(CSI,"0;31;40m");     { Zurücksetzen }
  66.  Write(CSI,Style,";3",fCol,";4",bCol,"m");
  67. end;
  68.  
  69. PROCEDURE GetConSize(VAR Zeilen : Integer; VAR Spalten : Integer);
  70. VAR IB : Address;
  71.     Win : WindowPtr;
  72.     RP : RastPortPtr;
  73.  
  74. { Ich habe das Ganze über die Intuition.library realisiert.
  75.   Daraus ergibt sich, daß das Shell-Fenster, von dem ihr
  76.   die Größe wissen wollt, das aktive Fenster des Screens
  77.   sein muß. Wenn ein anderes Fenster aktiv ist, erhaltet
  78.   ihr falsche Werte.
  79.   Man kann die Zeilen/Spalten auch irgendwie über das
  80.   Console.device herausfinden, aber das funktioniert bei
  81.   mir irgendwie nicht. :-(
  82. }
  83.  
  84. Begin
  85.  IB:=OpenLibrary("intuition.library",33);
  86.  Win:=IntuitionBasePtr(IB)^.ActiveWindow;
  87.  CloseLibrary(IB);
  88.  
  89.  RP:=Win^.RPort;
  90.  Zeilen:=(Win^.Height-Win^.BorderTop-Win^.BorderBottom) div RP^.TxHeight;
  91.  Spalten:=(Win^.Width-Win^.BorderLeft-Win^.BorderRight) div RP^.TxWidth;
  92. end;
  93.  
  94. PROCEDURE TxtLine(x1,y1,x2,y2 : Integer; c : Char);
  95. VAR m : Real;
  96.     x, y : Integer;
  97.     Test1, Test2 : Integer;
  98.     xold,yold : Integer;
  99.     v : Integer;
  100.  
  101. PROCEDURE Swap(VAR v1, v2 : Integer);
  102. BEGIN
  103.  v:=v1;
  104.  v1:=v2;
  105.  v2:=v;
  106. END;
  107.  
  108. BEGIN
  109.  XOld:=x2;
  110.  YOld:=y2;
  111.  
  112.  Test1:=x1-x2;
  113.  Test2:=y1-y2;
  114.  IF Test1<0 THEN Test1:=-Test1;
  115.  IF Test2<0 THEN Test2:=-Test2;
  116.  
  117.  IF Test1>Test2 THEN
  118.   BEGIN
  119.    IF (x2<x1) THEN
  120.     BEGIN
  121.      Swap(x1,x2);
  122.      Swap(y1,y2);
  123.     END;
  124.  
  125.    IF x1=x2 THEN Inc(x2);
  126.    m:=(y2-y1)/(x2-x1);
  127.    For x:=x1 to x2 do 
  128.     Begin
  129.      Locate(m*(x-x1)+y1+0.5,x);
  130.      Write(c);
  131.     end;
  132.   END
  133.  else
  134.   BEGIN
  135.    IF (y2<y1) THEN
  136.     BEGIN
  137.      Swap(x1,x2);
  138.      Swap(y1,y2);
  139.     END;
  140.  
  141.    IF y1=y2 THEN Inc(y2);
  142.    m:=(x2-x1)/(y2-y1);
  143.    for y:=y1 to y2 do 
  144.     Begin
  145.      Locate(y,m*(y-y1)+x1+0.5);
  146.      Write(c);
  147.     end;
  148.   END;
  149. END;
  150.  
  151. PROCEDURE HorizTxtLine(x,y,w : Integer; c : Char);
  152. VAR i : Integer;
  153.     Str : String;
  154. Begin
  155.  Str:=AllocString(200);
  156.  StrCpy(Str,"");
  157.  For i:=1 to w do StrCat(Str,adr(c));
  158.  Locate(y,x);
  159.  Write(Str);
  160. end;
  161.  
  162. PROCEDURE TxtRectFill(x,y,w,h : Integer; c : Char);
  163. VAR i : Integer;
  164.     Str : String;
  165. Begin
  166.  Str:=AllocString(200);
  167.  StrCpy(Str,"");
  168.  For i:=1 to w do StrCat(Str,adr(c));
  169.  For i:=0 to h-1 do
  170.   Begin
  171.    Locate(y+i,x);
  172.    Write(Str);
  173.   end;
  174. end;
  175.  
  176.